home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / back_end / comex.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  9.8 KB  |  247 lines
  1. (herald (back_end comex)
  2.   (env t (orbit_top defs) (back_end closure)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;; Copyright (c) 1985 David Kranz
  28.  
  29. (define (get-template-definer l)
  30.   (iterate loop ((l l))
  31.    (let ((node (node-parent l)))
  32.     (cond ((not node) 0)
  33.           ((and (eq? (lambda-strategy l) strategy/heap)
  34.                 (continuation? l))
  35.            0)
  36.           ((or (primop-ref? (call-proc node) primop/*define)
  37.            (primop-ref? (call-proc node) primop/*lset))
  38.            (let ((offset (cdr (ass (lambda (x y)
  39.                                  (and (loc-list? y)
  40.                                       (eq? x (loc-list-var y))))
  41.                               (leaf-value ((call-arg 2) node))
  42.                               (closure-env *unit*)))))
  43.              (fx/ offset 4)))
  44.           (else 
  45.            (loop (node-parent node)))))))
  46.  
  47. (define (template-has-superior? node)
  48.   (xselect (lambda-strategy node)
  49.     ((strategy/stack)                                          
  50.      (if (closure-vframe-lambdas (environment-closure (lambda-env node))) 0 1))
  51.     ((strategy/heap strategy/hack) 0)))
  52.  
  53. (define-structure-type lap-template-struct
  54.   pointer
  55.   scratch
  56.   nargs
  57.   handler-tag
  58.   strategy
  59.   instructions)
  60.  
  61.  
  62. (define (generate-lap-template node)
  63.   (destructure (((#f i-node) (call-args node)))
  64.     (let ((tem (make-lap-template-struct))
  65.           (i-stream (leaf-value i-node)))
  66.       (destructure (((pointer scratch nargs nary? strategy tag) (car i-stream)))
  67.         (set (lap-template-struct-pointer tem) (eval pointer orbit-env)) ; arghh
  68.         (set (lap-template-struct-scratch tem) (eval scratch orbit-env))
  69.         (set (lap-template-struct-nargs tem) (cons nargs nary?))
  70.         (set (lap-template-struct-strategy tem)
  71.              (if (eq? strategy 'stack) 0 1))
  72.         (set (lap-template-struct-handler-tag tem) tag)
  73.         (set (lap-template-struct-instructions tem) (cdr i-stream))
  74.         (lambda-queue tem)
  75.         (free-register node AN)    ; where set (define) code expects
  76.         (generate-move-address (template tem) AN)
  77.         (mark-continuation node AN)))))
  78.  
  79. (define (process-lap-template tem)
  80.   (emit-template tem (lap-template-struct-handler-tag tem))
  81.   (set *lambda* (car (find (lambda (pair) (lambda-node? (car pair)))
  82.                            (closure-env *unit*))))
  83.   (lap-transduce (lap-template-struct-instructions tem))
  84.   (process-lambda-queue))                                                                                
  85.  
  86. (define (create-comex filename h unit templates thing code)
  87.   (if (fx>= (bytev-length code) 65536)
  88.       (user-message-without-location 'error "Object file was too big~%" '#f))
  89.   (let ((size (fx+ (fx+ (length unit) 4) (fx* (length templates) 2))) ; hack,
  90.         (comex (make-comex)))                                         ; template
  91.     (receive (objects opcodes)                                        ; in both
  92.              (create-obj-op-vectors thing unit size filename h)
  93.       (set (comex-module-name comex) version-number)
  94.       (set (comex-code comex) code)
  95.       (set (comex-objects comex) objects)
  96.       (set (comex-opcodes comex) opcodes)           
  97.       (set (comex-annotation comex) nil)
  98.       comex)))
  99.  
  100. (define (create-obj-op-vectors thing unit size filename h)
  101.   (let ((objects (make-vector size))
  102.         (opcodes (make-bytev size)))
  103.     (set (bref opcodes 0) op/literal)                         
  104.     (vset objects 0 (->compiler-filename filename))
  105.     (set (bref opcodes 1) op/literal)                         
  106.     (vset objects 1 h)                       
  107.     (set (bref opcodes 2) op/literal)                         
  108.     (vset objects 2 'unit-env)                  
  109.     (set (bref opcodes 3) op/closure)
  110.     (vset objects 3 (code-vector-offset thing))
  111.     (iterate loop ((a-list unit) (i 4))         
  112.       (cond ((null? a-list)
  113.              (return objects opcodes))
  114.             ((closure? (caar a-list))
  115.              (vset objects i
  116.                    (code-vector-offset (cit->lambda (caar a-list))))
  117.              (set (bref opcodes i) op/template1)
  118.              (set (bref opcodes (fx+ i 1)) op/template2)
  119.              (set (bref opcodes (fx+ i 2)) op/template3)
  120.              (loop (cdr a-list) (fx+ i 3)))
  121.             (else
  122.              (receive (opcode obj) (comex-decipher (caar a-list))
  123.                (vset objects i obj)
  124.                (set (bref opcodes i) opcode)
  125.                (loop (cdr a-list) (fx+ i 1))))))))
  126.  
  127.  
  128. (define (->compiler-filename fn)
  129.   (list (cond ((filename-fs fn))
  130.               (else (fs-name (local-fs))))
  131.         (filename-dir fn)
  132.         (filename-name fn)
  133.         (cond ((filename-type fn))
  134.               (else 't))))
  135.  
  136.  
  137.  
  138.  
  139. (define (comex-decipher obj)
  140.   (cond ((foreign-name obj)
  141.          => (lambda (name) (return op/foreign name)))
  142.         ((and (node? obj) (lambda-node? obj))
  143.          (return op/closure (code-vector-offset obj)))
  144.         ((loc-list? obj)
  145.          (vcell-status (loc-list-var obj)))
  146.         ((not (variable? obj))
  147.          (return op/literal obj))
  148.         (else
  149.          (return op/variable-value (variable-name obj)))))
  150.  
  151. (define (vcell-status var)
  152.   (let ((name (variable-name var)))
  153.     (cond ((not (defined-variable? var))
  154.        (return op/vcell name))
  155.       (else
  156.        (case (defined-variable-variant var)
  157.          ((set) (return op/vcell name))
  158.          ((lset) (return op/vcell-lset name))
  159.          (else
  160.           (let ((l (defined-variable-value var)))
  161.         (cond ((and l
  162.                 (let ((node ((call-arg 3) (node-parent l))))
  163.                   (and (lambda-node? node)
  164.                    (assq node (closure-env *unit*)))))
  165.                => (lambda (pair)
  166.                 (return op/vcell-stored-definition
  167.                     (cons name (cdr pair)))))
  168.               (else
  169.                (return op/vcell-defined name))))))))))
  170.  
  171. (define (cit->lambda closure)
  172.   (variable-binder (car (closure-members closure))))
  173.  
  174. (define (static var-name)
  175.   (let* ((a-list (closure-env *unit*))
  176.          (val (ass (lambda (name var)
  177.                      (and (loc-list? var)
  178.               (eq? (variable-name (loc-list-var var)) name)))
  179.                    var-name
  180.                    a-list)))
  181.     (cond (val
  182.            (fx- (cdr val)
  183.                 (fx+ (cond ((assq *lambda* (cddr a-list))
  184.                             => cdr)
  185.                            (else
  186.                             (cdr (last a-list))))
  187.                       tag/extend)))
  188.           (else
  189.            (error "static value not mentioned ~s" var-name)))))
  190.  
  191.  
  192. (define (template-nary l)
  193.   (xcond ((lambda-node? l)                             
  194.           (cond ((object-lambda? l)
  195.                  (lambda-rest-var ((call-arg 2) (lambda-body l))))
  196.                 (else       
  197.                  (or (eq? (lambda-strategy l) strategy/vframe)
  198.                      (eq? (lambda-strategy l) strategy/ezclose)
  199.                      (lambda-rest-var l)))))
  200.          ((lap-template-struct? l)
  201.           (cdr (lap-template-struct-nargs l)))))
  202.  
  203.  
  204. (define (get-template-annotation l)
  205.   (xcond ((lambda-node? l)
  206.           
  207. (fx+ (fixnum-ashl (get-template-definer l) 3)
  208.   (fx+ (fixnum-ashl (template-has-superior? l) 2)
  209.      (fx+ (fixnum-ashl (if (eq? (lambda-strategy l) strategy/stack) 0 1) 1)
  210.           (if (fxn= (environment-cic-offset (lambda-env l)) 0) 1 0)))))
  211.  
  212.          ((lap-template-struct? l)
  213.      (fixnum-ashl (lap-template-struct-strategy l) 1))))
  214.  
  215.           
  216. (define (get-template-cells l)
  217.   (cond ((lap-template-struct? l)
  218.           (fx+ (fixnum-ashl (lap-template-struct-pointer l) 8)
  219.                (lap-template-struct-scratch l)))
  220.          ((environment? (lambda-env l))
  221.           (let ((offset (environment-cic-offset (lambda-env l))))
  222.             (cond ((fxn= offset 0) offset)
  223.                   (else
  224.                    (let ((closure (environment-closure (lambda-env l))))
  225.                      (fx+ (fixnum-ashl (closure-pointer closure) 8)
  226.                           (closure-scratch closure)))))))
  227.          (else 0)))
  228.           
  229.  
  230. (define (get-template-nargs l)
  231.   (xcond ((lambda-node? l)
  232.           (select (lambda-strategy l)
  233.             ((strategy/stack)
  234.              (fx- 0 (fx+ (length (lambda-variables l)) 1)))
  235.             ((strategy/vframe strategy/ezclose) -1)
  236.             (else
  237.              (cond ((object-lambda? l)
  238.                     (let ((proc ((call-arg 2) (lambda-body l))))
  239.                       (if (primop-ref? (call-proc (lambda-body proc))
  240.                                        primop/undefined-effect)
  241.                           0
  242.                           (length (lambda-variables proc)))))     
  243.                    (else
  244.                     (length (lambda-variables l)))))))
  245.          ((lap-template-struct? l)
  246.           (car (lap-template-struct-nargs l)))))
  247.